home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2007 September / PCWSEP07.iso / Software / Linux / Linux Mint 3.0 Light / LinuxMint-3.0-Light.iso / casper / filesystem.squashfs / usr / share / intltool-debian / intltool-merge < prev    next >
Encoding:
Text File  |  2006-11-08  |  38.0 KB  |  1,488 lines
  1. #!/usr/bin/perl -w
  2. # -*- Mode: perl; indent-tabs-mode: nil; c-basic-offset: 4  -*-
  3.  
  4. #
  5. #  The Intltool Message Merger
  6. #
  7. #  Copyright (C) 2000, 2003 Free Software Foundation.
  8. #  Copyright (C) 2000, 2001 Eazel, Inc
  9. #
  10. #  Intltool is free software; you can redistribute it and/or
  11. #  modify it under the terms of the GNU General Public License 
  12. #  version 2 published by the Free Software Foundation.
  13. #
  14. #  Intltool is distributed in the hope that it will be useful,
  15. #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17. #  General Public License for more details.
  18. #
  19. #  You should have received a copy of the GNU General Public License
  20. #  along with this program; if not, write to the Free Software
  21. #  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22. #
  23. #  As a special exception to the GNU General Public License, if you
  24. #  distribute this file as part of a program that contains a
  25. #  configuration script generated by Autoconf, you may include it under
  26. #  the same distribution terms that you use for the rest of that program.
  27. #
  28. #  Authors:  Maciej Stachowiak <mjs@noisehavoc.org>
  29. #            Kenneth Christiansen <kenneth@gnu.org>
  30. #            Darin Adler <darin@bentspoon.com>
  31. #
  32. #  Proper XML UTF-8'ification written by Cyrille Chepelov <chepelov@calixo.net>
  33. #
  34.  
  35. ## Release information
  36. my $PROGRAM = "intltool-merge";
  37. my $PACKAGE = "intltool";
  38. my $VERSION = "0.35.0";
  39.  
  40. ## Loaded modules
  41. use strict; 
  42. use Getopt::Long;
  43. use File::Basename;
  44.  
  45. my $must_end_tag      = -1;
  46. my $last_depth        = -1;
  47. my $translation_depth = -1;
  48. my @tag_stack = ();
  49. my @entered_tag = ();
  50. my @translation_strings = ();
  51. my $leading_space = "";
  52.  
  53. ## Scalars used by the option stuff
  54. my $HELP_ARG = 0;
  55. my $VERSION_ARG = 0;
  56. my $BA_STYLE_ARG = 0;
  57. my $XML_STYLE_ARG = 0;
  58. my $KEYS_STYLE_ARG = 0;
  59. my $DESKTOP_STYLE_ARG = 0;
  60. my $SCHEMAS_STYLE_ARG = 0;
  61. my $RFC822DEB_STYLE_ARG = 0;
  62. my $QUOTED_STYLE_ARG = 0;
  63. my $QUIET_ARG = 0;
  64. my $PASS_THROUGH_ARG = 0;
  65. my $UTF8_ARG = 0;
  66. my $MULTIPLE_OUTPUT = 0;
  67. my $cache_file;
  68.  
  69. ## Handle options
  70. GetOptions 
  71. (
  72.  "help" => \$HELP_ARG,
  73.  "version" => \$VERSION_ARG,
  74.  "quiet|q" => \$QUIET_ARG,
  75.  "oaf-style|o" => \$BA_STYLE_ARG, ## for compatibility
  76.  "ba-style|b" => \$BA_STYLE_ARG,
  77.  "xml-style|x" => \$XML_STYLE_ARG,
  78.  "keys-style|k" => \$KEYS_STYLE_ARG,
  79.  "desktop-style|d" => \$DESKTOP_STYLE_ARG,
  80.  "schemas-style|s" => \$SCHEMAS_STYLE_ARG,
  81.  "rfc822deb-style|r" => \$RFC822DEB_STYLE_ARG,
  82.  "quoted-style" => \$QUOTED_STYLE_ARG,
  83.  "pass-through|p" => \$PASS_THROUGH_ARG,
  84.  "utf8|u" => \$UTF8_ARG,
  85.  "multiple-output|m" => \$MULTIPLE_OUTPUT,
  86.  "cache|c=s" => \$cache_file
  87.  ) or &error;
  88.  
  89. my $PO_DIR;
  90. my $FILE;
  91. my $OUTFILE;
  92.  
  93. my %po_files_by_lang = ();
  94. my %translations = ();
  95. my $iconv = $ENV{"ICONV"} || $ENV{"INTLTOOL_ICONV"} || "/usr/bin/iconv";
  96. my $devnull = ($^O eq 'MSWin32' ? 'NUL:' : '/dev/null');
  97.  
  98. # Use this instead of \w for XML files to handle more possible characters.
  99. my $w = "[-A-Za-z0-9._:]";
  100.  
  101. # XML quoted string contents
  102. my $q = "[^\\\"]*";
  103.  
  104. ## Check for options. 
  105.  
  106. if ($VERSION_ARG) 
  107. {
  108.     &print_version;
  109. } 
  110. elsif ($HELP_ARG) 
  111. {
  112.     &print_help;
  113. } 
  114. elsif ($BA_STYLE_ARG && @ARGV > 2) 
  115. {
  116.     &utf8_sanity_check;
  117.     &preparation;
  118.     &print_message;
  119.     &ba_merge_translations;
  120.     &finalize;
  121. } 
  122. elsif ($XML_STYLE_ARG && @ARGV > 2) 
  123. {
  124.     &utf8_sanity_check;
  125.     &preparation;
  126.     &print_message;
  127.     &xml_merge_output;
  128.     &finalize;
  129. } 
  130. elsif ($KEYS_STYLE_ARG && @ARGV > 2) 
  131. {
  132.     &utf8_sanity_check;
  133.     &preparation;
  134.     &print_message;
  135.     &keys_merge_translations;
  136.     &finalize;
  137. } 
  138. elsif ($DESKTOP_STYLE_ARG && @ARGV > 2) 
  139. {
  140.     &utf8_sanity_check;
  141.     &preparation;
  142.     &print_message;
  143.     &desktop_merge_translations;
  144.     &finalize;
  145. } 
  146. elsif ($SCHEMAS_STYLE_ARG && @ARGV > 2) 
  147. {
  148.     &utf8_sanity_check;
  149.     &preparation;
  150.     &print_message;
  151.     &schemas_merge_translations;
  152.     &finalize;
  153. } 
  154. elsif ($RFC822DEB_STYLE_ARG && @ARGV > 2) 
  155. {
  156.     &preparation;
  157.     &rfc822deb_merge_translations;
  158.     &finalize;
  159. } 
  160. elsif ($QUOTED_STYLE_ARG && @ARGV > 2) 
  161. {
  162.     &utf8_sanity_check;
  163.     &preparation;
  164.     &print_message;
  165.     "ed_merge_translations;
  166.     &finalize;
  167. } 
  168. else 
  169. {
  170.     &print_help;
  171. }
  172.  
  173. exit;
  174.  
  175. ## Sub for printing release information
  176. sub print_version
  177. {
  178.     print <<_EOF_;
  179. ${PROGRAM} (${PACKAGE}) ${VERSION}
  180. Written by Maciej Stachowiak, Darin Adler and Kenneth Christiansen.
  181.  
  182. Copyright (C) 2000-2003 Free Software Foundation, Inc.
  183. Copyright (C) 2000-2001 Eazel, Inc.
  184. This is free software; see the source for copying conditions.  There is NO
  185. warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  186. _EOF_
  187.     exit;
  188. }
  189.  
  190. ## Sub for printing usage information
  191. sub print_help
  192. {
  193.     print <<_EOF_;
  194. Usage: ${PROGRAM} [OPTION]... PO_DIRECTORY FILENAME OUTPUT_FILE
  195. Generates an output file that includes some localized attributes from an
  196. untranslated source file.
  197.  
  198. Mandatory options: (exactly one must be specified)
  199.   -b, --ba-style         includes translations in the bonobo-activation style
  200.   -d, --desktop-style    includes translations in the desktop style
  201.   -k, --keys-style       includes translations in the keys style
  202.   -s, --schemas-style    includes translations in the schemas style
  203.   -r, --rfc822deb-style  includes translations in the RFC822 style
  204.       --quoted-style     includes translations in the quoted string style
  205.   -x, --xml-style        includes translations in the standard xml style
  206.  
  207. Other options:
  208.   -u, --utf8             convert all strings to UTF-8 before merging 
  209.                          (default for everything except RFC822 style)
  210.   -p, --pass-through     deprecated, does nothing and issues a warning
  211.   -m, --multiple-output  output one localized file per locale, instead of 
  212.                      a single file containing all localized elements
  213.   -c, --cache=FILE       specify cache file name
  214.                          (usually \$top_builddir/po/.intltool-merge-cache)
  215.   -q, --quiet            suppress most messages
  216.       --help             display this help and exit
  217.       --version          output version information and exit
  218.  
  219. Report bugs to http://bugzilla.gnome.org/ (product name "$PACKAGE")
  220. or send email to <xml-i18n-tools\@gnome.org>.
  221. _EOF_
  222.     exit;
  223. }
  224.  
  225.  
  226. ## Sub for printing error messages
  227. sub print_error
  228. {
  229.     print STDERR "Try `${PROGRAM} --help' for more information.\n";
  230.     exit;
  231. }
  232.  
  233.  
  234. sub print_message 
  235. {
  236.     print "Merging translations into $OUTFILE.\n" unless $QUIET_ARG;
  237. }
  238.  
  239.  
  240. sub preparation 
  241. {
  242.     $PO_DIR = $ARGV[0];
  243.     $FILE = $ARGV[1];
  244.     $OUTFILE = $ARGV[2];
  245.  
  246.     &gather_po_files;
  247.     &get_translation_database;
  248. }
  249.  
  250. # General-purpose code for looking up translations in .po files
  251.  
  252. sub po_file2lang
  253. {
  254.     my ($tmp) = @_; 
  255.     $tmp =~ s/^.*\/(.*)\.po$/$1/; 
  256.     return $tmp; 
  257. }
  258.  
  259. sub gather_po_files
  260. {
  261.     for my $po_file (glob "$PO_DIR/*.po") {
  262.     $po_files_by_lang{po_file2lang($po_file)} = $po_file;
  263.     }
  264. }
  265.  
  266. sub get_local_charset
  267. {
  268.     my ($encoding) = @_;
  269.     my $alias_file = $ENV{"G_CHARSET_ALIAS"} || "/usr/lib/charset.alias";
  270.  
  271.     # seek character encoding aliases in charset.alias (glib)
  272.  
  273.     if (open CHARSET_ALIAS, $alias_file) 
  274.     {
  275.     while (<CHARSET_ALIAS>) 
  276.         {
  277.             next if /^\#/;
  278.             return $1 if (/^\s*([-._a-zA-Z0-9]+)\s+$encoding\b/i)
  279.         }
  280.  
  281.         close CHARSET_ALIAS;
  282.     }
  283.  
  284.     # if not found, return input string
  285.  
  286.     return $encoding;
  287. }
  288.  
  289. sub get_po_encoding
  290. {
  291.     my ($in_po_file) = @_;
  292.     my $encoding = "";
  293.  
  294.     open IN_PO_FILE, $in_po_file or die;
  295.     while (<IN_PO_FILE>) 
  296.     {
  297.         ## example: "Content-Type: text/plain; charset=ISO-8859-1\n"
  298.         if (/Content-Type\:.*charset=([-a-zA-Z0-9]+)\\n/) 
  299.         {
  300.             $encoding = $1; 
  301.             last;
  302.         }
  303.     }
  304.     close IN_PO_FILE;
  305.  
  306.     if (!$encoding) 
  307.     {
  308.         print STDERR "Warning: no encoding found in $in_po_file. Assuming ISO-8859-1\n" unless $QUIET_ARG;
  309.         $encoding = "ISO-8859-1";
  310.     }
  311.  
  312.     system ("$iconv -f $encoding -t UTF-8 <$devnull 2>$devnull");
  313.     if ($?) {
  314.     $encoding = get_local_charset($encoding);
  315.     }
  316.  
  317.     return $encoding
  318. }
  319.  
  320. sub utf8_sanity_check 
  321. {
  322.     print STDERR "Warning: option --pass-through has been removed.\n" if $PASS_THROUGH_ARG;
  323.     $UTF8_ARG = 1;
  324. }
  325.  
  326. sub get_translation_database
  327. {
  328.     if ($cache_file) {
  329.     &get_cached_translation_database;
  330.     } else {
  331.         &create_translation_database;
  332.     }
  333. }
  334.  
  335. sub get_newest_po_age
  336. {
  337.     my $newest_age;
  338.  
  339.     foreach my $file (values %po_files_by_lang) 
  340.     {
  341.     my $file_age = -M $file;
  342.     $newest_age = $file_age if !$newest_age || $file_age < $newest_age;
  343.     }
  344.  
  345.     $newest_age = 0 if !$newest_age;
  346.  
  347.     return $newest_age;
  348. }
  349.  
  350. sub create_cache
  351. {
  352.     print "Generating and caching the translation database\n" unless $QUIET_ARG;
  353.  
  354.     &create_translation_database;
  355.  
  356.     open CACHE, ">$cache_file" || die;
  357.     print CACHE join "\x01", %translations;
  358.     close CACHE;
  359. }
  360.  
  361. sub load_cache 
  362. {
  363.     print "Found cached translation database\n" unless $QUIET_ARG;
  364.  
  365.     my $contents;
  366.     open CACHE, "<$cache_file" || die;
  367.     {
  368.         local $/;
  369.         $contents = <CACHE>;
  370.     }
  371.     close CACHE;
  372.     %translations = split "\x01", $contents;
  373. }
  374.  
  375. sub get_cached_translation_database
  376. {
  377.     my $cache_file_age = -M $cache_file;
  378.     if (defined $cache_file_age) 
  379.     {
  380.         if ($cache_file_age <= &get_newest_po_age) 
  381.         {
  382.             &load_cache;
  383.             return;
  384.         }
  385.         print "Found too-old cached translation database\n" unless $QUIET_ARG;
  386.     }
  387.  
  388.     &create_cache;
  389. }
  390.  
  391. sub create_translation_database
  392. {
  393.     for my $lang (keys %po_files_by_lang) 
  394.     {
  395.         my $po_file = $po_files_by_lang{$lang};
  396.  
  397.         if ($UTF8_ARG) 
  398.         {
  399.             my $encoding = get_po_encoding ($po_file);
  400.  
  401.             if (lc $encoding eq "utf-8") 
  402.             {
  403.                 open PO_FILE, "<$po_file";    
  404.             } 
  405.             else 
  406.             {
  407.         print "NOTICE: $po_file is not in UTF-8 but $encoding, converting...\n" unless $QUIET_ARG;;
  408.  
  409.                 open PO_FILE, "$iconv -f $encoding -t UTF-8 $po_file|";    
  410.             }
  411.         } 
  412.         else 
  413.         {
  414.             open PO_FILE, "<$po_file";    
  415.         }
  416.  
  417.     my $nextfuzzy = 0;
  418.     my $inmsgid = 0;
  419.     my $inmsgstr = 0;
  420.     my $msgid = "";
  421.     my $msgstr = "";
  422.  
  423.         while (<PO_FILE>) 
  424.         {
  425.         $nextfuzzy = 1 if /^#, fuzzy/;
  426.        
  427.         if (/^msgid "((\\.|[^\\])*)"/ ) 
  428.             {
  429.         $translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
  430.         $msgid = "";
  431.         $msgstr = "";
  432.  
  433.         if ($nextfuzzy) {
  434.             $inmsgid = 0;
  435.         } else {
  436.             $msgid = unescape_po_string($1);
  437.             $inmsgid = 1;
  438.         }
  439.         $inmsgstr = 0;
  440.         $nextfuzzy = 0;
  441.         }
  442.  
  443.         if (/^msgstr "((\\.|[^\\])*)"/) 
  444.             {
  445.             $msgstr = unescape_po_string($1);
  446.         $inmsgstr = 1;
  447.         $inmsgid = 0;
  448.         }
  449.  
  450.         if (/^"((\\.|[^\\])*)"/) 
  451.             {
  452.             $msgid .= unescape_po_string($1) if $inmsgid;
  453.             $msgstr .= unescape_po_string($1) if $inmsgstr;
  454.         }
  455.     }
  456.     $translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
  457.     }
  458. }
  459.  
  460. sub finalize
  461. {
  462. }
  463.  
  464. sub unescape_one_sequence
  465. {
  466.     my ($sequence) = @_;
  467.  
  468.     return "\\" if $sequence eq "\\\\";
  469.     return "\"" if $sequence eq "\\\"";
  470.     return "\n" if $sequence eq "\\n";
  471.     return "\r" if $sequence eq "\\r";
  472.     return "\t" if $sequence eq "\\t";
  473.     return "\b" if $sequence eq "\\b";
  474.     return "\f" if $sequence eq "\\f";
  475.     return "\a" if $sequence eq "\\a";
  476.     return chr(11) if $sequence eq "\\v"; # vertical tab, see ascii(7)
  477.  
  478.     return chr(hex($1)) if ($sequence =~ /\\x([0-9a-fA-F]{2})/);
  479.     return chr(oct($1)) if ($sequence =~ /\\([0-7]{3})/);
  480.  
  481.     # FIXME: Is \0 supported as well? Kenneth and Rodney don't want it, see bug #48489
  482.  
  483.     return $sequence;
  484. }
  485.  
  486. sub unescape_po_string
  487. {
  488.     my ($string) = @_;
  489.  
  490.     $string =~ s/(\\x[0-9a-fA-F]{2}|\\[0-7]{3}|\\.)/unescape_one_sequence($1)/eg;
  491.  
  492.     return $string;
  493. }
  494.  
  495. ## NOTE: deal with < - < but not > - >  because it seems its ok to have 
  496. ## > in the entity. For further info please look at #84738.
  497. sub entity_decode
  498. {
  499.     local ($_) = @_;
  500.  
  501.     s/'/'/g; # '
  502.     s/"/"/g; # "
  503.     s/&/&/g;
  504.     s/</</g;
  505.  
  506.     return $_;
  507. }
  508.  
  509. # entity_encode: (string)
  510. #
  511. # Encode the given string to XML format (encode '<' etc).
  512.  
  513. sub entity_encode
  514. {
  515.     my ($pre_encoded) = @_;
  516.  
  517.     my @list_of_chars = unpack ('C*', $pre_encoded);
  518.  
  519.     # with UTF-8 we only encode minimalistic
  520.     return join ('', map (&entity_encode_int_minimalist, @list_of_chars));
  521. }
  522.  
  523. sub entity_encode_int_minimalist
  524. {
  525.     return """ if $_ == 34;
  526.     return "&" if $_ == 38;
  527.     return "'" if $_ == 39;
  528.     return "<" if $_ == 60;
  529.     return chr $_;
  530. }
  531.  
  532. sub entity_encoded_translation
  533. {
  534.     my ($lang, $string) = @_;
  535.  
  536.     my $translation = $translations{$lang, $string};
  537.     return $string if !$translation;
  538.     return entity_encode ($translation);
  539. }
  540.  
  541. ## XML (bonobo-activation specific) merge code
  542.  
  543. sub ba_merge_translations
  544. {
  545.     my $source;
  546.  
  547.     {
  548.        local $/; # slurp mode
  549.        open INPUT, "<$FILE" or die "can't open $FILE: $!";
  550.        $source = <INPUT>;
  551.        close INPUT;
  552.     }
  553.  
  554.     open OUTPUT, ">$OUTFILE" or die "can't open $OUTFILE: $!";
  555.     # Binmode so that selftest works ok if using a native Win32 Perl...
  556.     binmode (OUTPUT) if $^O eq 'MSWin32';
  557.  
  558.     while ($source =~ s|^(.*?)([ \t]*<\s*$w+\s+($w+\s*=\s*"$q"\s*)+/?>)([ \t]*\n)?||s) 
  559.     {
  560.         print OUTPUT $1;
  561.  
  562.         my $node = $2 . "\n";
  563.  
  564.         my @strings = ();
  565.         $_ = $node;
  566.     while (s/(\s)_($w+\s*=\s*"($q)")/$1$2/s) {
  567.              push @strings, entity_decode($3);
  568.         }
  569.     print OUTPUT;
  570.  
  571.     my %langs;
  572.     for my $string (@strings) 
  573.         {
  574.         for my $lang (keys %po_files_by_lang) 
  575.             {
  576.                 $langs{$lang} = 1 if $translations{$lang, $string};
  577.         }
  578.     }
  579.     
  580.     for my $lang (sort keys %langs) 
  581.         {
  582.         $_ = $node;
  583.         s/(\sname\s*=\s*)"($q)"/$1"$2-$lang"/s;
  584.         s/(\s)_($w+\s*=\s*")($q)"/$1 . $2 . entity_encoded_translation($lang, $3) . '"'/seg;
  585.         print OUTPUT;
  586.         }
  587.     }
  588.  
  589.     print OUTPUT $source;
  590.  
  591.     close OUTPUT;
  592. }
  593.  
  594.  
  595. ## XML (non-bonobo-activation) merge code
  596.  
  597.  
  598. # Process tag attributes
  599. #   Only parameter is a HASH containing attributes -> values mapping
  600. sub getAttributeString
  601. {
  602.     my $sub = shift;
  603.     my $do_translate = shift || 0;
  604.     my $language = shift || "";
  605.     my $result = "";
  606.     my $translate = shift;
  607.     foreach my $e (reverse(sort(keys %{ $sub }))) {
  608.     my $key    = $e;
  609.     my $string = $sub->{$e};
  610.     my $quote = '"';
  611.     
  612.     $string =~ s/^[\s]+//;
  613.     $string =~ s/[\s]+$//;
  614.     
  615.     if ($string =~ /^'.*'$/)
  616.     {
  617.         $quote = "'";
  618.     }
  619.     $string =~ s/^['"]//g;
  620.     $string =~ s/['"]$//g;
  621.  
  622.     if ($do_translate && $key =~ /^_/) {
  623.         $key =~ s|^_||g;
  624.         if ($language) {
  625.         # Handle translation
  626.         my $decode_string = entity_decode($string);
  627.         my $translation = $translations{$language, $decode_string};
  628.         if ($translation) {
  629.             $translation = entity_encode($translation);
  630.             $string = $translation;
  631.                 }
  632.                 $$translate = 2;
  633.             } else {
  634.                  $$translate = 2 if ($translate && (!$$translate)); # watch not to "overwrite" $translate
  635.             }
  636.     }
  637.     
  638.     $result .= " $key=$quote$string$quote";
  639.     }
  640.     return $result;
  641. }
  642.  
  643. # Returns a translatable string from XML node, it works on contents of every node in XML::Parser tree
  644. sub getXMLstring
  645. {
  646.     my $ref = shift;
  647.     my $spacepreserve = shift || 0;
  648.     my @list = @{ $ref };
  649.     my $result = "";
  650.  
  651.     my $count = scalar(@list);
  652.     my $attrs = $list[0];
  653.     my $index = 1;
  654.  
  655.     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  656.     $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
  657.  
  658.     while ($index < $count) {
  659.     my $type = $list[$index];
  660.     my $content = $list[$index+1];
  661.         if (! $type ) {
  662.         # We've got CDATA
  663.         if ($content) {
  664.         # lets strip the whitespace here, and *ONLY* here
  665.                 $content =~ s/\s+/ /gs if (!$spacepreserve);
  666.         $result .= $content;
  667.         }
  668.     } elsif ( "$type" ne "1" ) {
  669.         # We've got another element
  670.         $result .= "<$type";
  671.         $result .= getAttributeString(@{$content}[0], 0); # no nested translatable elements
  672.         if ($content) {
  673.         my $subresult = getXMLstring($content, $spacepreserve);
  674.         if ($subresult) {
  675.             $result .= ">".$subresult . "</$type>";
  676.         } else {
  677.             $result .= "/>";
  678.         }
  679.         } else {
  680.         $result .= "/>";
  681.         }
  682.     }
  683.     $index += 2;
  684.     }
  685.     return $result;
  686. }
  687.  
  688. # Translate list of nodes if necessary
  689. sub translate_subnodes
  690. {
  691.     my $fh = shift;
  692.     my $content = shift;
  693.     my $language = shift || "";
  694.     my $singlelang = shift || 0;
  695.     my $spacepreserve = shift || 0;
  696.  
  697.     my @nodes = @{ $content };
  698.  
  699.     my $count = scalar(@nodes);
  700.     my $index = 0;
  701.     while ($index < $count) {
  702.         my $type = $nodes[$index];
  703.         my $rest = $nodes[$index+1];
  704.         if ($singlelang) {
  705.             my $oldMO = $MULTIPLE_OUTPUT;
  706.             $MULTIPLE_OUTPUT = 1;
  707.             traverse($fh, $type, $rest, $language, $spacepreserve);
  708.             $MULTIPLE_OUTPUT = $oldMO;
  709.         } else {
  710.             traverse($fh, $type, $rest, $language, $spacepreserve);
  711.         }
  712.         $index += 2;
  713.     }
  714. }
  715.  
  716. sub isWellFormedXmlFragment
  717. {
  718.     my $ret = eval 'require XML::Parser';
  719.     if(!$ret) {
  720.         die "You must have XML::Parser installed to run $0\n\n";
  721.     } 
  722.  
  723.     my $fragment = shift;
  724.     return 0 if (!$fragment);
  725.  
  726.     $fragment = "<root>$fragment</root>";
  727.     my $xp = new XML::Parser(Style => 'Tree');
  728.     my $tree = 0;
  729.     eval { $tree = $xp->parse($fragment); };
  730.     return $tree;
  731. }
  732.  
  733. sub traverse
  734. {
  735.     my $fh = shift; 
  736.     my $nodename = shift;
  737.     my $content = shift;
  738.     my $language = shift || "";
  739.     my $spacepreserve = shift || 0;
  740.  
  741.     if (!$nodename) {
  742.     if ($content =~ /^[\s]*$/) {
  743.         $leading_space .= $content;
  744.     }
  745.     print $fh $content;
  746.     } else {
  747.     # element
  748.     my @all = @{ $content };
  749.     my $attrs = shift @all;
  750.     my $translate = 0;
  751.     my $outattr = getAttributeString($attrs, 1, $language, \$translate);
  752.  
  753.     if ($nodename =~ /^_/) {
  754.         $translate = 1;
  755.         $nodename =~ s/^_//;
  756.     }
  757.     my $lookup = '';
  758.  
  759.         $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
  760.         $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  761.  
  762.     print $fh "<$nodename", $outattr;
  763.     if ($translate) {
  764.         $lookup = getXMLstring($content, $spacepreserve);
  765.             if (!$spacepreserve) {
  766.                 $lookup =~ s/^\s+//s;
  767.                 $lookup =~ s/\s+$//s;
  768.             }
  769.  
  770.         if ($lookup || $translate == 2) {
  771.                 my $translation = $translations{$language, $lookup} if isWellFormedXmlFragment($translations{$language, $lookup});
  772.                 if ($MULTIPLE_OUTPUT && ($translation || $translate == 2)) {
  773.                     $translation = $lookup if (!$translation);
  774.                     print $fh " xml:lang=\"", $language, "\"" if $language;
  775.                     print $fh ">";
  776.                     if ($translate == 2) {
  777.                         translate_subnodes($fh, \@all, $language, 1, $spacepreserve);
  778.                     } else {
  779.                         print $fh $translation;
  780.                     }
  781.                     print $fh "</$nodename>";
  782.  
  783.                     return; # this means there will be no same translation with xml:lang="$language"...
  784.                             # if we want them both, just remove this "return"
  785.                 } else {
  786.                     print $fh ">";
  787.                     if ($translate == 2) {
  788.                         translate_subnodes($fh, \@all, $language, 1, $spacepreserve);
  789.                     } else {
  790.                         print $fh $lookup;
  791.                     }
  792.                     print $fh "</$nodename>";
  793.                 }
  794.         } else {
  795.         print $fh "/>";
  796.         }
  797.  
  798.         for my $lang (sort keys %po_files_by_lang) {
  799.                     if ($MULTIPLE_OUTPUT && $lang ne "$language") {
  800.                         next;
  801.                     }
  802.             if ($lang) {
  803.                         # Handle translation
  804.                         #
  805.                         my $translate = 0;
  806.                         my $localattrs = getAttributeString($attrs, 1, $lang, \$translate);
  807.                         my $translation = $translations{$lang, $lookup} if isWellFormedXmlFragment($translations{$lang, $lookup});
  808.                         if ($translate && !$translation) {
  809.                             $translation = $lookup;
  810.                         }
  811.  
  812.                         if ($translation || $translate) {
  813.                 print $fh "\n";
  814.                 $leading_space =~ s/.*\n//g;
  815.                 print $fh $leading_space;
  816.                  print $fh "<", $nodename, " xml:lang=\"", $lang, "\"", $localattrs, ">";
  817.                             if ($translate == 2) {
  818.                                translate_subnodes($fh, \@all, $lang, 1, $spacepreserve);
  819.                             } else {
  820.                                 print $fh $translation;
  821.                             }
  822.                             print $fh "</$nodename>";
  823.             }
  824.                     }
  825.         }
  826.  
  827.     } else {
  828.         my $count = scalar(@all);
  829.         if ($count > 0) {
  830.         print $fh ">";
  831.                 my $index = 0;
  832.                 while ($index < $count) {
  833.                     my $type = $all[$index];
  834.                     my $rest = $all[$index+1];
  835.                     traverse($fh, $type, $rest, $language, $spacepreserve);
  836.                     $index += 2;
  837.                 }
  838.         print $fh "</$nodename>";
  839.         } else {
  840.         print $fh "/>";
  841.         }
  842.     }
  843.     }
  844. }
  845.  
  846. sub intltool_tree_comment
  847. {
  848.     my $expat = shift;
  849.     my $data  = shift;
  850.     my $clist = $expat->{Curlist};
  851.     my $pos   = $#$clist;
  852.  
  853.     push @$clist, 1 => $data;
  854. }
  855.  
  856. sub intltool_tree_cdatastart
  857. {
  858.     my $expat    = shift;
  859.     my $clist = $expat->{Curlist};
  860.     my $pos   = $#$clist;
  861.  
  862.     push @$clist, 0 => $expat->original_string();
  863. }
  864.  
  865. sub intltool_tree_cdataend
  866. {
  867.     my $expat    = shift;
  868.     my $clist = $expat->{Curlist};
  869.     my $pos   = $#$clist;
  870.  
  871.     $clist->[$pos] .= $expat->original_string();
  872. }
  873.  
  874. sub intltool_tree_char
  875. {
  876.     my $expat = shift;
  877.     my $text  = shift;
  878.     my $clist = $expat->{Curlist};
  879.     my $pos   = $#$clist;
  880.  
  881.     # Use original_string so that we retain escaped entities
  882.     # in CDATA sections.
  883.     #
  884.     if ($pos > 0 and $clist->[$pos - 1] eq '0') {
  885.         $clist->[$pos] .= $expat->original_string();
  886.     } else {
  887.         push @$clist, 0 => $expat->original_string();
  888.     }
  889. }
  890.  
  891. sub intltool_tree_start
  892. {
  893.     my $expat    = shift;
  894.     my $tag      = shift;
  895.     my @origlist = ();
  896.  
  897.     # Use original_string so that we retain escaped entities
  898.     # in attribute values.  We must convert the string to an
  899.     # @origlist array to conform to the structure of the Tree
  900.     # Style.
  901.     #
  902.     my @original_array = split /\x/, $expat->original_string();
  903.     my $source         = $expat->original_string();
  904.  
  905.     # Remove leading tag.
  906.     #
  907.     $source =~ s|^\s*<\s*(\S+)||s;
  908.  
  909.     # Grab attribute key/value pairs and push onto @origlist array.
  910.     #
  911.     while ($source)
  912.     {
  913.        if ($source =~ /^\s*([\w:-]+)\s*[=]\s*["]/)
  914.        {
  915.            $source =~ s|^\s*([\w:-]+)\s*[=]\s*["]([^"]*)["]||s;
  916.            push @origlist, $1;
  917.            push @origlist, '"' . $2 . '"';
  918.        }
  919.        elsif ($source =~ /^\s*([\w:-]+)\s*[=]\s*[']/)
  920.        {
  921.            $source =~ s|^\s*([\w:-]+)\s*[=]\s*[']([^']*)[']||s;
  922.            push @origlist, $1;
  923.            push @origlist, "'" . $2 . "'";
  924.        }
  925.        else
  926.        {
  927.            last;
  928.        }
  929.     }
  930.  
  931.     my $ol = [ { @origlist } ];
  932.  
  933.     push @{ $expat->{Lists} }, $expat->{Curlist};
  934.     push @{ $expat->{Curlist} }, $tag => $ol;
  935.     $expat->{Curlist} = $ol;
  936. }
  937.  
  938. sub readXml
  939. {
  940.     my $filename = shift || return;
  941.     if(!-f $filename) {
  942.         die "ERROR Cannot find filename: $filename\n";
  943.     }
  944.  
  945.     my $ret = eval 'require XML::Parser';
  946.     if(!$ret) {
  947.         die "You must have XML::Parser installed to run $0\n\n";
  948.     } 
  949.     my $xp = new XML::Parser(Style => 'Tree');
  950.     $xp->setHandlers(Char => \&intltool_tree_char);
  951.     $xp->setHandlers(Start => \&intltool_tree_start);
  952.     $xp->setHandlers(CdataStart => \&intltool_tree_cdatastart);
  953.     $xp->setHandlers(CdataEnd => \&intltool_tree_cdataend);
  954.     my $tree = $xp->parsefile($filename);
  955.  
  956. # <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
  957. # would be:
  958. # [foo, [{}, head, [{id => "a"}, 0, "Hello ",  em, [{}, 0, "there"]], bar, [{},
  959. # 0, "Howdy",  ref, [{}]], 0, "do" ] ]
  960.  
  961.     return $tree;
  962. }
  963.  
  964. sub print_header
  965. {
  966.     my $infile = shift;
  967.     my $fh = shift;
  968.     my $source;
  969.  
  970.     if(!-f $infile) {
  971.         die "ERROR Cannot find filename: $infile\n";
  972.     }
  973.  
  974.     print $fh qq{<?xml version="1.0" encoding="UTF-8"?>\n};
  975.     {
  976.         local $/;
  977.         open DOCINPUT, "<${FILE}" or die;
  978.         $source = <DOCINPUT>;
  979.         close DOCINPUT;
  980.     }
  981.     if ($source =~ /(<!DOCTYPE.*\[.*\]\s*>)/s)
  982.     {
  983.         print $fh "$1\n";
  984.     }
  985.     elsif ($source =~ /(<!DOCTYPE[^>]*>)/s)
  986.     {
  987.         print $fh "$1\n";
  988.     }
  989. }
  990.  
  991. sub parseTree
  992. {
  993.     my $fh        = shift;
  994.     my $ref       = shift;
  995.     my $language  = shift || "";
  996.  
  997.     my $name = shift @{ $ref };
  998.     my $cont = shift @{ $ref };
  999.     
  1000.     while (!$name || "$name" eq "1") {
  1001.         $name = shift @{ $ref };
  1002.         $cont = shift @{ $ref };
  1003.     }
  1004.  
  1005.     my $spacepreserve = 0;
  1006.     my $attrs = @{$cont}[0];
  1007.     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  1008.  
  1009.     traverse($fh, $name, $cont, $language, $spacepreserve);
  1010. }
  1011.  
  1012. sub xml_merge_output
  1013. {
  1014.     my $source;
  1015.  
  1016.     if ($MULTIPLE_OUTPUT) {
  1017.         for my $lang (sort keys %po_files_by_lang) {
  1018.         if ( ! -e $lang ) {
  1019.             mkdir $lang or die "Cannot create subdirectory $lang: $!\n";
  1020.             }
  1021.             open OUTPUT, ">$lang/$OUTFILE" or die "Cannot open $lang/$OUTFILE: $!\n";
  1022.             binmode (OUTPUT) if $^O eq 'MSWin32';
  1023.             my $tree = readXml($FILE);
  1024.             print_header($FILE, \*OUTPUT);
  1025.             parseTree(\*OUTPUT, $tree, $lang);
  1026.             close OUTPUT;
  1027.             print "CREATED $lang/$OUTFILE\n" unless $QUIET_ARG;
  1028.         }
  1029.     } 
  1030.     open OUTPUT, ">$OUTFILE" or die "Cannot open $OUTFILE: $!\n";
  1031.     binmode (OUTPUT) if $^O eq 'MSWin32';
  1032.     my $tree = readXml($FILE);
  1033.     print_header($FILE, \*OUTPUT);
  1034.     parseTree(\*OUTPUT, $tree);
  1035.     close OUTPUT;
  1036.     print "CREATED $OUTFILE\n" unless $QUIET_ARG;
  1037. }
  1038.  
  1039. sub keys_merge_translations
  1040. {
  1041.     open INPUT, "<${FILE}" or die;
  1042.     open OUTPUT, ">${OUTFILE}" or die;
  1043.     binmode (OUTPUT) if $^O eq 'MSWin32';
  1044.  
  1045.     while (<INPUT>) 
  1046.     {
  1047.         if (s/^(\s*)_(\w+=(.*))/$1$2/)  
  1048.         {
  1049.         my $string = $3;
  1050.  
  1051.             print OUTPUT;
  1052.  
  1053.         my $non_translated_line = $_;
  1054.  
  1055.             for my $lang (sort keys %po_files_by_lang) 
  1056.             {
  1057.         my $translation = $translations{$lang, $string};
  1058.                 next if !$translation;
  1059.  
  1060.                 $_ = $non_translated_line;
  1061.         s/(\w+)=.*/[$lang]$1=$translation/;
  1062.                 print OUTPUT;
  1063.             }
  1064.     } 
  1065.         else 
  1066.         {
  1067.             print OUTPUT;
  1068.         }
  1069.     }
  1070.  
  1071.     close OUTPUT;
  1072.     close INPUT;
  1073. }
  1074.  
  1075. sub desktop_merge_translations
  1076. {
  1077.     open INPUT, "<${FILE}" or die;
  1078.     open OUTPUT, ">${OUTFILE}" or die;
  1079.     binmode (OUTPUT) if $^O eq 'MSWin32';
  1080.  
  1081.     while (<INPUT>) 
  1082.     {
  1083.         if (s/^(\s*)_(\w+=(.*))/$1$2/)  
  1084.         {
  1085.         my $string = $3;
  1086.  
  1087.             print OUTPUT;
  1088.  
  1089.         my $non_translated_line = $_;
  1090.  
  1091.             for my $lang (sort keys %po_files_by_lang) 
  1092.             {
  1093.                 my $translation = $translations{$lang, $string};
  1094.                 next if !$translation;
  1095.  
  1096.                 $_ = $non_translated_line;
  1097.                 s/(\w+)=.*/${1}[$lang]=$translation/;
  1098.                 print OUTPUT;
  1099.             }
  1100.     } 
  1101.         else 
  1102.         {
  1103.             print OUTPUT;
  1104.         }
  1105.     }
  1106.  
  1107.     close OUTPUT;
  1108.     close INPUT;
  1109. }
  1110.  
  1111. sub schemas_merge_translations
  1112. {
  1113.     my $source;
  1114.  
  1115.     {
  1116.        local $/; # slurp mode
  1117.        open INPUT, "<$FILE" or die "can't open $FILE: $!";
  1118.        $source = <INPUT>;
  1119.        close INPUT;
  1120.     }
  1121.  
  1122.     open OUTPUT, ">$OUTFILE" or die;
  1123.     binmode (OUTPUT) if $^O eq 'MSWin32';
  1124.  
  1125.     # FIXME: support attribute translations
  1126.  
  1127.     # Empty nodes never need translation, so unmark all of them.
  1128.     # For example, <_foo/> is just replaced by <foo/>.
  1129.     $source =~ s|<\s*_($w+)\s*/>|<$1/>|g;
  1130.  
  1131.     while ($source =~ s/
  1132.                         (.*?)
  1133.                         (\s+)(<locale\ name="C">(\s*)
  1134.                             (<default>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/default>)?(\s*)
  1135.                             (<short>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/short>)?(\s*)
  1136.                             (<long>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/long>)?(\s*)
  1137.                         <\/locale>)
  1138.                        //sx) 
  1139.     {
  1140.         print OUTPUT $1;
  1141.  
  1142.     my $locale_start_spaces = $2 ? $2 : '';
  1143.     my $default_spaces = $4 ? $4 : '';
  1144.     my $short_spaces = $7 ? $7 : '';
  1145.     my $long_spaces = $10 ? $10 : '';
  1146.     my $locale_end_spaces = $13 ? $13 : '';
  1147.     my $c_default_block = $3 ? $3 : '';
  1148.     my $default_string = $6 ? $6 : '';
  1149.     my $short_string = $9 ? $9 : '';
  1150.     my $long_string = $12 ? $12 : '';
  1151.  
  1152.     print OUTPUT "$locale_start_spaces$c_default_block";
  1153.  
  1154.         $default_string =~ s/\s+/ /g;
  1155.         $default_string = entity_decode($default_string);
  1156.     $short_string =~ s/\s+/ /g;
  1157.     $short_string = entity_decode($short_string);
  1158.     $long_string =~ s/\s+/ /g;
  1159.     $long_string = entity_decode($long_string);
  1160.  
  1161.     for my $lang (sort keys %po_files_by_lang) 
  1162.         {
  1163.         my $default_translation = $translations{$lang, $default_string};
  1164.         my $short_translation = $translations{$lang, $short_string};
  1165.         my $long_translation  = $translations{$lang, $long_string};
  1166.  
  1167.         next if (!$default_translation && !$short_translation && 
  1168.                      !$long_translation);
  1169.  
  1170.         print OUTPUT "\n$locale_start_spaces<locale name=\"$lang\">";
  1171.  
  1172.         print OUTPUT "$default_spaces";    
  1173.  
  1174.         if ($default_translation)
  1175.         {
  1176.             $default_translation = entity_encode($default_translation);
  1177.             print OUTPUT "<default>$default_translation</default>";
  1178.         }
  1179.  
  1180.         print OUTPUT "$short_spaces";
  1181.  
  1182.         if ($short_translation)
  1183.         {
  1184.             $short_translation = entity_encode($short_translation);
  1185.             print OUTPUT "<short>$short_translation</short>";
  1186.         }
  1187.  
  1188.         print OUTPUT "$long_spaces";
  1189.  
  1190.         if ($long_translation)
  1191.         {
  1192.             $long_translation = entity_encode($long_translation);
  1193.             print OUTPUT "<long>$long_translation</long>";
  1194.         }        
  1195.  
  1196.         print OUTPUT "$locale_end_spaces</locale>";
  1197.         }
  1198.     }
  1199.  
  1200.     print OUTPUT $source;
  1201.  
  1202.     close OUTPUT;
  1203. }
  1204.  
  1205. sub rfc822deb_merge_translations
  1206. {
  1207.     my %encodings = ();
  1208.     for my $lang (keys %po_files_by_lang) {
  1209.         $encodings{$lang} = ($UTF8_ARG ? 'UTF-8' : get_po_encoding($po_files_by_lang{$lang}));
  1210.     }
  1211.  
  1212.     my $source;
  1213.  
  1214.     {
  1215.        local $/; # slurp mode
  1216.        open INPUT, "<$FILE" or die "can't open $FILE: $!";
  1217.        $source = <INPUT>;
  1218.        close INPUT;
  1219.     }
  1220.  
  1221.     open OUTPUT, ">${OUTFILE}" or die;
  1222.     binmode (OUTPUT) if $^O eq 'MSWin32';
  1223.  
  1224.     my $last = 0;
  1225.     while ($source =~ /\G(.*?)(^|\n)(_+)([^:\s]+)(:[ \t]*)(.*?)(?=\n[\S\n]|$)/sg)
  1226.     {
  1227.         $last = pos($source);
  1228.         my ($pre, $newline, $underscore, $tag, $space, $text) = ($1, $2, $3, $4, $5, $6);
  1229.         my $non_translated_line = $tag.$space;
  1230.         $underscore = length($underscore);
  1231.         #  Print untranslated fields
  1232.         my $untranslated_fields = $pre;
  1233.         $untranslated_fields =~ s/\n#.*//g;
  1234.         $untranslated_fields =~ s/^#.*(\n|$)//;
  1235.         print OUTPUT $untranslated_fields;
  1236.         #  Remove [] dummy strings
  1237.         my $stripped = $text;
  1238.         $stripped =~ s/\[\s[^\[\]]*\],/,/g
  1239.             if $underscore == 2;
  1240.         $stripped =~ s/\[\s[^\[\]]*\]$//;
  1241.         $non_translated_line .= $stripped;
  1242.  
  1243.         print OUTPUT $newline.$non_translated_line;
  1244.     
  1245.         if ($underscore) 
  1246.         {
  1247.             my @str_list = rfc822deb_split($underscore, $text);
  1248.             my $partial = 0;
  1249.  
  1250.             #  Process pseudo-comments
  1251.             my @tfields = ();
  1252.             if ($pre =~ m/^#flag:/m)
  1253.             {
  1254.                 my @c = split (/\n#flag:/, $pre);
  1255.                 #  The first field is null
  1256.                 shift (@c);
  1257.                 for (@c)
  1258.                 {
  1259.                     if (s/^comment(!?):(\S+)(?=\n|$)//s)
  1260.                     {
  1261.                         # This command is ignored by intltool-merge
  1262.                     }
  1263.                     elsif (s/^translate(!?):(\S+)(?=\n|$)//s)
  1264.                     {
  1265.                         rfc822deb_parse_spec($2, $1, 1+$#str_list, 0, 1, \@tfields);
  1266.                     }
  1267.                     elsif (s/^partial(?=\n|$)//s)
  1268.                     {
  1269.                         $partial = 1;
  1270.                     }
  1271.                     else
  1272.                     {
  1273.                         die "Unknown directive: $_\n\nAborting!\n";
  1274.                     }
  1275.                 }
  1276.             }
  1277.             #  By default, print all msgids
  1278.             rfc822deb_parse_spec('*', '', 1+$#str_list, 0, 1, \@tfields)
  1279.                 if $#tfields == -1;
  1280.  
  1281.             for my $lang (sort keys %po_files_by_lang) 
  1282.             {
  1283.                 my $is_translated = 1;
  1284.                 my $str_translated = '';
  1285.                 my $cnt = 0;
  1286.             
  1287.                 for my $str (@str_list) 
  1288.                 {
  1289.                     $cnt++;
  1290.                     my $translation;
  1291.                     if ($tfields[$cnt] && $str ne '')
  1292.                     {
  1293.                         $translation = $translations{$lang, $str};
  1294.                         if (!$translation) 
  1295.                         {
  1296.                             if ($partial)
  1297.                             {
  1298.                                 $translation = $str;
  1299.                             }
  1300.                             else
  1301.                             {
  1302.                                 $is_translated = 0;
  1303.                                 last;
  1304.                             }
  1305.                         }
  1306.                     }
  1307.                     else
  1308.                     {
  1309.                         $translation = $str;
  1310.                     }
  1311.  
  1312.                     #  $translation may also contain [] dummy
  1313.                     #  strings, mostly to indicate an empty string
  1314.                     $translation =~ s/\[\s[^\[\]]*\]$//;
  1315.  
  1316.                     #  Escape commas
  1317.                     $translation =~ s/,/\\,/g
  1318.                         if $underscore == 2;
  1319.                     
  1320.                     if ($cnt == 1) 
  1321.                     {
  1322.                         print STDERR "WARNING: $lang: spurious newline removed\n"
  1323.                             if $translation =~ s/\n/ /g;
  1324.                         $str_translated .= $translation;
  1325.                     } 
  1326.                     else 
  1327.                     {
  1328.                         if ($underscore == 2)
  1329.                         {
  1330.                             $str_translated .= ', ' . $translation;
  1331.                         }
  1332.                         else
  1333.                         {
  1334.                             $translation =~ s/\n/\n /g;
  1335.                             $str_translated .= "\n ." unless $cnt == 2;
  1336.                             $str_translated .= "\n " . $translation unless $str eq '';
  1337.                         }
  1338.                     }
  1339.                 }
  1340.                 next unless $is_translated;
  1341.  
  1342.                 $str_translated =~ s/\s+$//;
  1343.                 $str_translated = ' '.$str_translated if length ($str_translated) && $str_translated !~ /^\n/s;
  1344.  
  1345.                 $_ = $non_translated_line;
  1346.                 s/^(\w+):\s*.*/$newline${1}-$lang.$encodings{$lang}:$str_translated/s;
  1347.                 print OUTPUT;
  1348.             }
  1349.         }
  1350.     }
  1351.     my $tail = substr($source, $last);
  1352.     $tail .= "\n" unless $tail =~ m/\n$/s;
  1353.     $tail =~ s/^#.*\n//mg;
  1354.  
  1355.     print OUTPUT $tail;
  1356.  
  1357.     close OUTPUT;
  1358.     close INPUT;
  1359. }
  1360.  
  1361. sub rfc822deb_parse_spec {
  1362.     my $spec = shift;
  1363.     my $negate = shift;
  1364.     my $len = shift;
  1365.     my $notfound = shift;
  1366.     my $found = shift;
  1367.     my $ref = shift;
  1368.     $spec = ','.$spec.',';
  1369.     #  Replace '*' by all values
  1370.     my $all = '1-'.$len;
  1371.     $spec =~ s/\*/$all/g;
  1372.     #  Expand ranges
  1373.     $spec =~ s/(\d+)-(\d+)/join(",", ($1..$2))/eg;
  1374.     if ($#{$ref} == -1)
  1375.     {
  1376.         for my $cnt (1..$len)
  1377.         {
  1378.             $ref->[$cnt] = $notfound;
  1379.         }
  1380.     }
  1381.     for my $cnt (1..$len)
  1382.     {
  1383.         if ($spec =~ m/,$cnt,/ && !$negate) {
  1384.             $ref->[$cnt] .= $found;
  1385.         } elsif ($spec !~ m/,$cnt,/ && $negate) {
  1386.             $ref->[$cnt] .= $found;
  1387.         }
  1388.     }
  1389. }
  1390.  
  1391. sub rfc822deb_split 
  1392. {
  1393.     # Debian defines a special way to deal with rfc822-style files:
  1394.     # when a value contain newlines, it consists of
  1395.     #   1.  a short form (first line)
  1396.     #   2.  a long description, all lines begin with a space,
  1397.     #       and paragraphs are separated by a single dot on a line
  1398.     # This routine returns an array of all paragraphs, and reformat
  1399.     # them.
  1400.     # When first argument is 2, the string is a comma separated list of
  1401.     # values.
  1402.     my $type = shift;
  1403.     my $text = shift;
  1404.     $text =~ s/^[ \t]//mg;
  1405.     if ($type ne 1)
  1406.     {
  1407.         my @values = ();
  1408.         for my $value (split(/(?<!\\), */, $text, 0))
  1409.         {
  1410.             $value =~ s/\\,/,/g;
  1411.             push @values, $value;
  1412.         }
  1413.         return @values;
  1414.     }
  1415.     return ($text) if $text !~ /\n/;
  1416.  
  1417.     $text =~ s/([^\n]*)\n//;
  1418.     my @list = ($1);
  1419.     my $str = '';
  1420.  
  1421.     for my $line (split (/\n/, $text)) 
  1422.     {
  1423.         chomp $line;
  1424.         if ($line =~ /^\.\s*$/)
  1425.         {
  1426.             #  New paragraph
  1427.             $str =~ s/\s*$//;
  1428.             push(@list, $str);
  1429.             $str = '';
  1430.         } 
  1431.         elsif ($line =~ /^\s/) 
  1432.         {
  1433.             #  Line which must not be reformatted
  1434.             $str .= "\n" if length ($str) && $str !~ /\n$/;
  1435.             $line =~ s/\s+$//;
  1436.             $str .= $line."\n";
  1437.         } 
  1438.         else 
  1439.         {
  1440.             #  Continuation line, remove newline
  1441.             $str .= " " if length ($str) && $str !~ /\n$/;
  1442.             $str .= $line;
  1443.         }
  1444.     }
  1445.  
  1446.     $str =~ s/\s*$//;
  1447.     push(@list, $str) if length ($str);
  1448.  
  1449.     return @list;
  1450. }
  1451.  
  1452. sub quoted_translation
  1453. {
  1454.     my ($lang, $string) = @_;
  1455.  
  1456.     $string =~ s/\\\"/\"/g;
  1457.  
  1458.     my $translation = $translations{$lang, $string};
  1459.     $translation = $string if !$translation;
  1460.  
  1461.     $translation =~ s/\"/\\\"/g;
  1462.     return $translation
  1463. }
  1464.  
  1465. sub quoted_merge_translations
  1466. {
  1467.     if (!$MULTIPLE_OUTPUT) {
  1468.         print "Quoted only supports Multiple Output.\n";
  1469.         exit(1);
  1470.     }
  1471.  
  1472.     for my $lang (sort keys %po_files_by_lang) {
  1473.         if ( ! -e $lang ) {
  1474.             mkdir $lang or die "Cannot create subdirectory $lang: $!\n";
  1475.         }
  1476.         open INPUT, "<${FILE}" or die;
  1477.         open OUTPUT, ">$lang/$OUTFILE" or die "Cannot open $lang/$OUTFILE: $!\n";
  1478.         binmode (OUTPUT) if $^O eq 'MSWin32';
  1479.         while (<INPUT>) 
  1480.         {
  1481.             s/\"(([^\"]|\\\")*[^\\\"])\"/"\"" . "ed_translation($lang, $1) . "\""/ge;
  1482.             print OUTPUT;
  1483.         }
  1484.         close OUTPUT;
  1485.         close INPUT;
  1486.     }
  1487. }
  1488.